home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 005 / pcpm.arc / CPASORT.BAS (.txt) < prev    next >
Encoding:
GW-BASIC  |  1985-06-04  |  5.6 KB  |  191 lines
  1. 100  REM CPASORT
  2. 102  CLOSE
  3. 110  DEFINT B-Z:DEFSNG A
  4. 112  DIM X$(12),R6$(500)
  5. 114  FOR I=1 TO 12
  6. 116  READ X$(I)
  7. 118  NEXT I
  8. 120  DATA "JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP","OCT","NOV","DEC"
  9. 122  DIM S(500),F(500),D$(500),D(500),O2(500),ES(500),EF(500),LS(500),LF(500)
  10. 124  DIM A(1500),P(500),A3(100),B(500),S$(48),M$(11),S2(500)
  11. 126  PRINT FRE(0)
  12. 128  B4=VAL(MID$(DATE$,1,2))
  13. 130  B5=VAL(MID$(DATE$,4,2))
  14. 132  B6=VAL(MID$(DATE$,9,2))
  15. 150  GOSUB 5000  'READ INPUT FILE
  16. 190  O5=11
  17. 200  FOR I=1 TO O5:READ M$(I):NEXT
  18. 210  DATA "NO SORT (RETURN TO MENU)","FROM NODES","TO NODES","ESTIMATED DURATIONS","ACTUAL DURATIONS","EARLY START DATES","LATE START DATES","EARLY FINISH DATES","LATE FINISH DATES","FLOAT","SUBCONTRACTOR CODES"
  19. 300  GOSUB 9000  'READ IN SORT FILE
  20. 400  PRINT :PRINT :PRINT TAB(23);"CHOICE OF SORTS":PRINT
  21. 410  FOR I=1 TO O5
  22. 420  PRINT TAB(10);M$(I);TAB(48);"-";:PRINT USING " ##";I-1
  23. 430  NEXT
  24. 440  PRINT :INPUT "Enter the number of your sort choice ";P
  25. 450  IF P=0 THEN CHAIN "CPAMENU"
  26. 460  IF P>O5 THEN BEEP:PRINT "**** INVALID CHOICE ****":GOTO 440
  27. 500  REM TRANSFER ARRAY TO BE SORTED
  28. 505  ON P GOTO 510,515,520,525,530,535,540,545,550,555
  29. 510  FOR K=1 TO N:S2(K)=S(K):NEXT:GOTO 600
  30. 515  FOR K=1 TO N:S2(K)=F(K):NEXT:GOTO 600
  31. 520  FOR K=1 TO N:S2(K)=O2(K):NEXT:GOTO 600
  32. 525  FOR K=1 TO N:S2(K)=D(K):NEXT:GOTO 600
  33. 530  FOR K=1 TO N:S2(K)=ES(K):NEXT:GOTO 600
  34. 535  FOR K=1 TO N:S2(K)=LS(K):NEXT:GOTO 600
  35. 540  FOR K=1 TO N:S2(K)=EF(K):NEXT:GOTO 600
  36. 545  FOR K=1 TO N:S2(K)=LF(K):NEXT:GOTO 600
  37. 550  FOR K=1 TO N:S2(K)=LF(K)-EF(K):NEXT:GOTO 600
  38. 555  FOR K=1 TO N:S2(K)=B(K):NEXT:GOTO 600
  39. 600  PRINT "**** SORTING"N"ACTIVITIES - TAKES";INT(N/3);"SECONDS IN REGULAR BASIC ****"
  40. 610  GOSUB 3140  'SHELL-METZNER SORT
  41. 690  PRINT "**** FINISHED SORT - FIGURING DAYS - TAKES";INT(C3/4);"SECONDS ****"
  42. 695  GOSUB 8000 'READ HOLIDAYS
  43. 700  GOSUB 7000  'FIGURE DAYS WITH MESSAGE
  44. 710  PRINT "**** DAYS FIGURED - READING SUBCONTRACTORS ****"
  45. 750  GOSUB 4800 'READ IN SUBCONTRACTORS
  46. 770  H$=F$+".SRT"
  47. 800  PRINT "Output File Name is ";H$;" O.K. (Y/N) ";
  48. 810  INPUT Q$
  49. 820  IF Q$="N" THEN INPUT "Enter new output file name [WITHOUT .SRT] ";H$
  50. 825  IF LEN(H$)>12 THEN PRINT "**** INVALID FILE NAME ****":BEEP:GOTO 820
  51. 830  OPEN H$ FOR OUTPUT AS #2
  52. 1250  IF LEN(P$)>60 THEN P1$=LEFT$(P$,60) ELSE P1$=P$
  53. 1260  T4=INT((118-52-LEN(P1$))/2)
  54. 1270  PRINT #2,TAB(T4);"CRITICAL PATH ANALYSIS FOR: ";P1$;" RUN DATE: ";X$(B4);B5;", 19";RIGHT$(STR$(B6),2)
  55. 1280  PRINT #2,G9$
  56. 1290  T4=((120-15-LEN(T6$))/2)
  57. 1300  PRINT #2,TAB(T4);"TIME PERIOD = ";T6$
  58. 1310  PRINT #2,G9$
  59. 1320  W4$=" DESCRIPTION                     "
  60. 1330  W$="ACTIVITY"+W4$+"FROM   TO  EST. ACTUAL  EARLY    LAST     EARLY    LAST  FLOAT C REPORT  SUBCONTRACTOR"
  61. 1340  W1$="NODE  NODE TIME  TIME   START    START    FINISH  FINISH  TIME P FINISH      NAME"
  62. 1350  PRINT #2,W$
  63. 1360  PRINT #2,TAB(42);W1$
  64. 1370  PRINT #2,G9$
  65. 1380  S4$="\                                      \"
  66. 1390  S5$=" \     \  \     \ "
  67. 1400  S$=S4$+" #### #### ####  ####  "+S5$+S5$+"#### ! \     \ \          \"
  68. 1410  S1$=S4$+" , #### , #### , #### , #### , #### , #### , #### , #### , #### , \     \ , ## "
  69. 1420  FOR J=1 TO N
  70. 1430  I=P(J)
  71. 1440  IF T7=1 THEN A7=LF(I)+1 ELSE A7=A(LF(I)+1)
  72. 1460  GOSUB 7550
  73. 1470  R4$=P6$
  74. 1480  IF T7=1 THEN A7=ES(I)+1 ELSE A7=A(ES(I)+1)
  75. 1500  GOSUB 7550
  76. 1510  R1$=P6$
  77. 1520  IF T7=1 THEN A7=LS(I)+1 ELSE A7=A(LS(I)+1)
  78. 1540  GOSUB 7550
  79. 1550  R2$=P6$
  80. 1560  IF T7=1 THEN A7=EF(I)+1 ELSE A7=A(EF(I)+1)
  81. 1580  GOSUB 7550
  82. 1590  R3$=P6$
  83. 1600  IF R6$(I)="0" THEN R6$(I)=" "
  84. 1660  IF LF(I)-EF(I)=0 THEN G1$="*" ELSE G1$=" "
  85. 1670  PRINT #2,USING S$;D$(I),S(I),F(I),O2(I),D(I),R1$,R2$,R3$,R4$,LF(I)-EF(I),G1$,R6$(I),S$(B(I))
  86. 1690  NEXT
  87. 1700  CLOSE #2
  88. 1710  PRINT:PRINT "**** OUTPUT FILED IN ";F$;".SRT ****"
  89. 1720  GOTO 400
  90. 3140  REM **** SHELL METZNER SORT ****************************************
  91. 3150  J=N
  92. 3160  FOR I=1 TO N:P(I)=J:J=J-1:NEXT I
  93. 3200  M=N
  94. 3210  M=INT(M/2)
  95. 3220  IF M=0 THEN RETURN
  96. 3230  J=1
  97. 3240  K=N-M
  98. 3250  I=J
  99. 3260  L=I+M
  100. 3270  IF S2(P(I))<S2(P(L)) THEN 3340
  101. 3280  SWAP P(I),P(L)
  102. 3310  I=I-M
  103. 3320  IF I<1 THEN 3340
  104. 3330  GOTO 3260
  105. 3340  J=J+1
  106. 3350  IF J>K THEN 3210
  107. 3360  GOTO 3250
  108. 4800  ON ERROR GOTO 4900
  109. 4805  OPEN F$+".SBC" FOR INPUT AS #1
  110. 4810  I=0
  111. 4820  I=I+1
  112. 4830  IF EOF(1) THEN 4860
  113. 4840  INPUT #1,S$(I)
  114. 4850  GOTO 4820
  115. 4860  PRINT "**** FILE ";F$;".SBC READ -";I-1;"SUBCONTRACTORS READ ****"
  116. 4865  NSBC=I-1
  117. 4867  CLOSE #1
  118. 4870  RETURN
  119. 4900  PRINT "**** NO SUBCONTRACTOR FILE - CONTINUING ****":NSBC=0:RESUME 4870
  120. 5000  REM **** READING IN ALREADY CREATED INPUT FILE ******************
  121. 5010  INPUT "Enter the name of the input file [.CPM] ";G$
  122. 5015  IF G$="Q" OR G$="QUIT" THEN 3500
  123. 5020  P=INSTR(1,G$,"."):IF P<>0 THEN F$=LEFT$(G$,INSTR(1,G$,".")-1) ELSE F$=G$
  124. 5030  IF LEN(F$)>8 THEN PRINT "**** NOT A VALID PCPM FILE ****":BEEP:GOTO 5010
  125. 5035  ON ERROR GOTO 5300
  126. 5037  G$=F$+".CPM"
  127. 5040  OPEN G$ FOR INPUT AS #3
  128. 5050  INPUT #3,P$,T6$,DA$
  129. 5060  IF LEFT$(T6$,3)="WOR" OR LEFT$(T6$,3)="CAL" THEN T7=0 ELSE T7=1
  130. 5150  CLOSE #3
  131. 5160  PRINT " **** INPUT FILE READ ****"
  132. 5170  RETURN
  133. 5300  PRINT "**** FILE DOES NOT EXIST - TRY AGAIN ****":BEEP:GOTO 5000
  134. 7000  REM ** CREATE ARRAY OF MMDDYYS ******************************
  135. 7010  REM IF A(1)=0 THEN A(1)=M6*10000+D6*100+Y6
  136. 7020  D1=D1+1
  137. 7030  IF D1>C3+1 THEN RETURN
  138. 7040  A8=A8+1
  139. 7050  GOSUB 7130
  140. 7060  IF LEFT$(T6$,3)="CAL" THEN 7070 ELSE IF D4=6 OR D4=7 THEN 7040
  141. 7070  O8=0
  142. 7080  GOSUB 7240
  143. 7090  IF O8=1 THEN 7040
  144. 7100  A(D1)=M5*10000+D5*100+Y5
  145. 7110  GOTO 7020
  146. 7120  REM ** CONVERT CENTURY DAY TO MM, DD, YY **************************
  147. 7130  T9=INT(A8/1461)
  148. 7140  Y5=INT((A8-T9+364)/365)
  149. 7150  Y4=A8-INT((Y5-1)*1461/4)
  150. 7160  L8=2
  151. 7170  IF Y5/4=INT(Y5/4) THEN L8=1
  152. 7180  T9=Y4
  153. 7190  IF T9>61-L8 THEN T9=T9+L8
  154. 7200  M5=INT((T9*9+269)/275)
  155. 7210  D5=T9-INT(M5*275/9)+30
  156. 7220  D4=A8-INT(A8/7)*7+1
  157. 7230  RETURN
  158. 7240  FOR J=1 TO H9   '**** HOLIDAY OR NOT ***********************************
  159. 7250  IF A8=A3(J) THEN O8=1
  160. 7260  NEXT J
  161. 7270  RETURN
  162. 7550  P6$=STR$(A7)
  163. 7560  IF T7=1 THEN 7600
  164. 7570  IF LEN(P6$)=6 THEN P6$=" "+P6$
  165. 7580  U9=VAL(LEFT$(P6$,3))
  166. 7590  P6$=X$(U9)+RIGHT$(P6$,4)
  167. 7600  RETURN
  168. 8000  ON ERROR GOTO 8200
  169. 8010  OPEN F$+".HOL" FOR INPUT AS #1
  170. 8020  J=0
  171. 8030  J=J+1
  172. 8040  IF EOF(1) THEN 8100
  173. 8050  INPUT #1,A3(J)
  174. 8060  GOTO 8030
  175. 8100  H9=J-1  'NUMBER OF HOLIDAYS
  176. 8110  CLOSE #1:RETURN
  177. 8200  PRINT "**** NO HOLIDAY FILE - CONTINUING ****":RESUME 8110
  178. 9000  REM READING IN SORT FILE
  179. 9010  ON ERROR GOTO 9200    'NO SORT FILE
  180. 9020  OPEN F$+".LGS" FOR INPUT AS #1
  181. 9030  INPUT #1,A8,A(1),C3
  182. 9040  I=0
  183. 9050  I=I+1
  184. 9060  IF EOF(1) THEN 9100
  185. 9070  INPUT #1,D$(I),S(I),F(I),O2(I),D(I),ES(I),LS(I),EF(I),LF(I),FL,R6$(I),B(I)
  186. 9075  IF I MOD 10=0 THEN PRINT I;
  187. 9080  GOTO 9050
  188. 9100  N=I-1
  189. 9110  CLOSE #1:RETURN
  190. 9200  PRINT "FILE ";F$;".LGS MUST BE CREATED BY OPTION 5 FIRST AND EXIST ON DISK****":BEEP:CHAIN "CPAMENU"
  191.